home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / elflib.zip / ETABLES.LSP < prev    next >
Text File  |  1992-12-01  |  13KB  |  419 lines
  1. ;;; ETABLES.LSP
  2. ;;; Copyright 1992 by Mountain Software
  3. ;;;
  4. ;;; This program requires ELF, the Extended Lisp Function library
  5. ;;;
  6. ;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
  7. ;;; WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
  8. ;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
  9. ;;;    
  10. ;;; adapted from: TABLES.LSP
  11. ;;; by Duff Kurland - Autodesk, Inc.
  12.  
  13. (Princ "\nLoading eTables.Lsp")
  14. (Load"ELF")
  15.  
  16. ;;;  Dump all the symbol tables
  17.  
  18. (DeFun C:TABLES (/ olderr ocmd key key2 mlist clist video vcol vrow)
  19.   (SetQ olderr    *error*
  20.     *error*  myerror
  21.     ocmd     (GetVar "cmdecho")
  22.     mlist     '("Layer" "LineType" "View" "Style" "Block" "UCS" "ViewPort")
  23.     clist     '(layer ltype view style block ucs vport)
  24.     video     (Get_Video )
  25.     vcol     (1-(Car video))
  26.     vrow     (1-(Cadr video))
  27.     dashline (Strnset "=" 80)
  28.   )
  29.   (SetVar "cmdecho" 0)
  30.   (Cls 7) (Set_Color 23)
  31.   (While(And (/= key2 F10_Key)(/= key Esc_Key))
  32.     (Wopen 0 0 vcol 3 30 23 2)
  33.     (Wputcen "ELF Tables")
  34.     (Scr_Fill 0 vrow vcol 1 32 65)
  35.     (Prts 1 vrow "F1 - Help  Esc - Exit  F10 - Exit Symbol Leaving Data" 65)
  36.     (SetQ ans (Wmenu mlist -1 -1 23 23 65 "Select")
  37.       key (Cadr ans)
  38.       i   (Car ans))
  39.     (If (= key Enter_Key)
  40.       (SetQ key2 (Eval(List(Nth i clist)))))      ; execute the command
  41.     (If (/= key2 F10_Key)
  42.       (Cls 7))
  43.   )
  44.   (SetVar "cmdecho" ocmd)
  45.   (SetQ *error* olderr)           ; Restore old *error* handler
  46.   (Princ)
  47. )
  48.  
  49. (DeFun C:ETABLES() (C:TABLES))          ; A command alias
  50.  
  51. (DeFun MYERROR (s)              ; If an error (such as CTRL-C) occurs
  52.                                       ; while this command is active...
  53.   (Beep)
  54.   (Wmsg (Strcat "eTables ERROR\n" s) 1 (| white red_bg))
  55.   (SetVar "cmdecho" ocmd)             ; Restore saved modes
  56.   (SetQ *error* olderr)               ; Restore old *error* handler
  57.   (WcloseAll)                  ; Close any open windows
  58.   (Cls 7)
  59.   (Princ)
  60. )
  61.  
  62. ;;;  (LAYER) - Dump the layer table
  63.  
  64. (DeFun LAYER ( / c d f ln lt ly n x layers)
  65.   (Wmsg "Loading Layers..." nil 64)
  66.   (WgotoXY 0 2)
  67.   (tblset "layer")
  68.   (SetQ layers (List "  Layer           Status  Color Linetype     Description"
  69.              dashline)
  70.     cl (GetVar "clayer")          ; get current layer
  71.     n  0
  72.     x  (next T))              ; get first layer
  73.   (While x
  74.     (SetQ n  (1+ n)
  75.           ly (fld  2 x)               ; layer name
  76.           ln (fld  6 x)               ; linetype name
  77.           c  (fld 62 x)               ; color number
  78.           f  (LogAnd (fld 70 x) 1)    ; "frozen" flag
  79.           lt (TblSearch "ltype" ln)   ; linetype table entry
  80.           d  (fld  3 lt)              ; linetype prose description
  81.     )
  82.     (Werase_Line 2)
  83.     (Wputcen ly)
  84.     (applst 'layers (Sprintf "%s %-15.15s %-7.7s %-5d %-12.12s %-.30s"
  85.       (If (= ly cl) "*" " ")      ; flag current layer
  86.       ly
  87.       (Cond 
  88.     ((= f 1) "Frozen") ; edit status
  89.     ((< c 0) "Off")
  90.     (T     "On")
  91.       )
  92.       (Abs c) ln d
  93.     ))
  94.     (SetQ x (next nil))           ; get next layer entry
  95.   )
  96.   (If (= n 0)
  97.     (applst 'layers "  -None-"))
  98.   (Wclose)
  99.   (Symbol layers)                      ; display it
  100. )
  101.  
  102. ;;;  (LTYPE) - Dump the linetype table
  103.  
  104. (DeFun LTYPE ( / a cl d f lt n s x linetype)
  105.   (Wmsg "Loading Linetypes..." nil 64)
  106.   (WgotoXY 0 2)
  107.   (tblset "ltype")
  108.   (SetQ linetype (List "  Linetype    Align  Segs  Description" dashline)
  109.     cl (GetVar "celtype")         ; get current linetype
  110.     f  "*")                       ; set default "current" flag
  111.  
  112.   ;;  If current linetype is "BYLAYER", look up the linetype
  113.   ;;  associated with the current layer, and change the
  114.   ;;  "current" flag from "* " to "L ".
  115.  
  116.   (SetQ cl
  117.     (Cond 
  118.       ((= cl "BYBLOCK") "")
  119.       ((= cl "BYLAYER") 
  120.         (SetQ f "L ")
  121.         (fld 6 (TblSearch "layer" (GetVar "clayer")))
  122.       )
  123.       (T cl)
  124.     )
  125.   )
  126.   (SetQ n 0)
  127.   (SetQ x (next T))                   ; first linetype
  128.   (While x
  129.     (SetQ n  (1+ n)
  130.           lt (fld  2 x)               ; linetype name
  131.     )
  132.     (Werase_Line 2)
  133.     (Wputcen lt)
  134.     (applst 'linetype
  135.       (Sprintf "%2.2s%-12.12s%-7.7c%-6d%-30.30s"
  136.     (If (= lt cl) f "")           ; flag current entity linetype
  137.     lt                  ; edit linetype name
  138.     (fld 72 x)              ; alignment code
  139.     (SetQ s (fld 73 x))          ; number of dash length items
  140.     (fld  3 x)              ; linetype prose description
  141.     ))
  142.     (If (> s 0) 
  143.       (Progn
  144.  
  145.         ;;;  Edit dash length items
  146.  
  147.         (SetQ x (Member (Assoc 49 x) x)) ; get list of dash items
  148.         (While x
  149.       (SetQ s (cdar x))         ; get dash length
  150.       (applst 'linetype (Sprintf "                           %s"
  151.         (Cond 
  152.           ((= s 0) "Dot")
  153.           ((> s 0) (StrCat "Pen down " (RtoS s 2 4)))
  154.           (T       (StrCat "Pen up   " (RtoS (Abs s) 2 4)))
  155.         )
  156.       ))
  157.           (SetQ x (Cdr x))            ; get next dash item
  158.         )
  159.       )
  160.     )
  161.     (SetQ x (next nil))               ; get next linetype entry
  162.   )
  163.   (If (= n 0)
  164.     (applst 'linetype "  -None-"))
  165.   (Wclose)
  166.   (Symbol linetype)
  167. )
  168.  
  169. ;;;  (VIEW) - Dump the named view table
  170.  
  171. (DeFun VIEW ( / c d h n v w x views)
  172.   (Wmsg "Loading Views..." nil 64)
  173.   (tblset "view")
  174.   (SetQ views (List
  175.       "  View        Height x Width        Center        Direction" dashline)
  176.     n 0
  177.     x (next T))              ; get first view
  178.   (While x
  179.     (SetQ n  (1+ n)
  180.           v  (fld  2 x)               ; view name
  181.           c  (fld 10 x)               ; center point
  182.           d  (fld 11 x)               ; view direction
  183.           h  (fld 40 x)               ; height
  184.           w  (fld 41 x)               ; width (valid only for windows)
  185.     )
  186.     (applst 'views
  187.       (Sprintf "  %-10.10s%8.2f x %-8.2f:%8.2f,%-8.2f:%.2f,%.2f,%.2f"
  188.     v h w (Car c) (Cadr c) (Car d) (Cadr d) (Caddr d)))
  189.     (SetQ x (next nil))               ; get next view entry
  190.   )
  191.   (If (= n 0)
  192.     (applst 'views "  -None-"))
  193.   (Wclose)
  194.   (Symbol views)
  195. )
  196.  
  197. ;;;  (STYLE) - Dump the text style table
  198.  
  199. (DeFun STYLE ( / cs fb ff g h n o s w x styles)
  200.   (Wmsg "Loading Styles..." nil 64)
  201.   (WgotoXY 0 2)
  202.   (tblset "style")
  203.   (SetQ styles (List
  204.       "  Text style    Height  Width   Slant  Flags  Font      Bigfont"
  205.       dashline)
  206.     cs (GetVar "textstyle")       ; get current style
  207.     n  0
  208.     x  (next T))              ; get first style
  209.   (While x
  210.     (SetQ n  (1+ n)
  211.           s  (fld  2 x)               ; style name
  212.           ff (fld  3 x)               ; primary font file
  213.           fb (fld  4 x)               ; big font file
  214.           h  (fld 40 x)               ; height
  215.           w  (fld 41 x)               ; width factor
  216.           o  (fld 50 x)               ; obliquing angle
  217.           g  (fld 71 x)               ; generation flags
  218.     )
  219.     (Werase_Line 2)
  220.     (Wputcen s)
  221.     (applst 'styles (Sprintf "%s %-12.12s%8.4f%8.4f%7s%7d  %-10s%-20s"
  222.     (If (= s cs) "*" " ")         ; flag current style
  223.     s h w (AngtoS o 0 2) g ff fb
  224.     ))
  225.     (SetQ x (next nil))               ; get next style entry
  226.   )
  227.   (If (= n 0)
  228.     (applst 'styles "  -None-"))
  229.   (Wclose)
  230.   (Symbol styles)
  231. )
  232.  
  233. ;;;  (BLOCK) - Dump the block definition table
  234.  
  235. (DeFun BLOCK ( / b e ec ed et f n o x blocks)
  236.   (Wmsg "Loading Blocks..." nil 64)
  237.   (WgotoXY 0 2)
  238.   (tblset "block")
  239.   (SetQ blocks (List "  Block       Flags  Origin" dashline)
  240.     n 0
  241.     x (next T))              ; get first block definition
  242.   (While x
  243.     (SetQ n  (1+ n)
  244.           b  (fld  2 x)               ; block name
  245.           o  (fld 10 x)               ; origin X,Y,Z
  246.           f  (fld 70 x)               ; flags
  247.     )
  248.     (Werase_Line 2)
  249.     (Wputcen b)
  250.     (applst 'blocks (Sprintf "  %-12.12s%-7d%.4f, %.4f, %.4f"
  251.       b f (Car o) (Cadr o) (Caddr o)))
  252.     ;;;  Display interesting facts about the entities comprising
  253.     ;;;  this block definition.
  254.  
  255.     (If(= (SubStr b 1 1) "*")          ; skip anonomous blocks
  256.       (applst 'blocks (Sprintf "%14sAnonomous Block (Hatch)" ""))
  257.     ;else
  258.     (Progn
  259.       (SetQ e (fld -2 x))               ; point to first entity
  260.       (While e
  261.         (SetQ ed (EntGet e)             ; get the entity data
  262.               et (fld  0 ed)            ; entity type
  263.               ec (fld 62 ed))           ; entity color
  264.         (applst 'blocks (Sprintf "%14s%9s on layer %s with color %s"
  265.           " " et
  266.           (fld 8 ed)                  ; edit layer name
  267.           (Cond 
  268.             ((= ec 0)  "BYBLOCK")     ; edit color number
  269.             ((Null ec) "BYLAYER")
  270.             (T         (ItoA ec))
  271.           )
  272.         ))
  273.         (If (SetQ e (EntNext e))        ; if there's another entity,
  274.             (SetQ ed (EntGet e))        ; read its data
  275.         )
  276.       )
  277.     ))
  278.     (SetQ x (next nil))               ; get next block entry
  279.   )
  280.   (If (= n 0)
  281.     (applst 'blocks "  -None-"))
  282.   (Wclose)
  283.   (Symbol blocks)
  284. )
  285.  
  286. ;;;  (UCS) - Dump the UCS table
  287.  
  288. (DeFun UCS ( / n x na o xd yd oa xs ys)
  289.   (Wmsg "Loading UCS..." nil 64)
  290.   (tblset "ucs")
  291.   (SetQ ucses (List
  292.      "  UCS         Origin              X axis direction    Y axis direction"
  293.      dashline)
  294.        n  0
  295.        x  (next T))             ; get first ucs
  296.   (While x
  297.     (SetQ n  (1+ n)
  298.           na (fld  2 x)               ; UCS name
  299.           o  (fld 10 x)               ; origin
  300.       os (Sprintf "(%.2f,%.2f,%.2f)" (Car o) (Cadr o) (Caddr o))
  301.           xd (fld 11 x)               ; X axis direction
  302.       xs (Sprintf "(%.2f,%.2f,%.2f)" (Car xd) (Cadr xd) (Caddr xd))
  303.           yd (fld 12 x)               ; Y axis direction
  304.       ys (Sprintf "(%.2f,%.2f,%.2f)" (Car yd) (Cadr yd) (Caddr yd))
  305.     )
  306.     (applst 'ucses
  307.       (Sprintf "%s %-12.12s%-20.20s%-20.20s%-20.20s"
  308.     (If (= na cucs) "*" " ")      ; flag current UCS
  309.     na os xs ys)
  310.     )
  311.     (SetQ x (next nil))               ; get next UCS entry
  312.   )
  313.   (If (= n 0)
  314.     (applst 'ucses "  -None-"))
  315.   (Wclose)
  316.   (Symbol ucses)
  317. )
  318.  
  319. ;;;  (VPORT) - Dump the viewport table
  320.  
  321. (DeFun VPORT ( / n x na ll ur v)
  322.   (Wmsg "Loading Vports..." nil 64)
  323.   (SetQ prev nil)
  324.   (tblset "vport")
  325.   (SetQ vports (List "  Viewport    Lower left     Upper Right     View Mode"
  326.              dashline)
  327.     n  0
  328.     x  (nextvp T prev))          ; get first viewport
  329.   (While x
  330.     (SetQ n  (1+ n)
  331.           na (fld  2 x)               ; viewport name
  332.           ll (fld 10 x)               ; lower left corner
  333.       ls (Sprintf "(%.2f,%.2f)" (Car ll) (Cadr ll))
  334.           ur (fld 11 x)               ; upper right corner
  335.       rs (Sprintf "(%.2f,%.2f)" (Car ur) (Cadr ur))
  336.           v  (fld 71 x)               ; view mode
  337.     )
  338.     (applst 'vports
  339.       (Sprintf "  %-10.10s  %-15.15s%-15.15s %f" na ls rs v))
  340.     (SetQ x (nextvp nil prev))        ; get next viewport entry
  341.   )
  342.   (If (= n 0)
  343.     (applst 'vports "  -None-"))
  344.   (Wclose)
  345.   (Symbol vports)
  346. )
  347.  
  348. ;;; append a value to a list
  349.  
  350. (DeFun APPLST (&lst val)
  351.   (SetQ lst (Append (Eval &lst) (List val)))
  352.   (Set &lst lst)
  353. )
  354.  
  355. ;;;  Return the value associated with a particular entity field
  356.  
  357. (DeFun FLD (num lst)
  358.   (Cdr (Assoc num lst))
  359. )
  360.  
  361. ;;;  Set up to process specified symbol table.
  362. ;;;  obtain all entries and sort them forming TBLENTS list.
  363.  
  364. (DeFun TBLSET (tbl / new s)
  365.   (SetQ tblname tbl)                  ; set table name
  366.   (SetQ tblents nil)          ; start with null list
  367.   (SetQ new (Cdr (Assoc 2 (TblNext tbl T)))) ; get first entry name
  368.   (While new
  369.     (SetQ tblents (Cons new tblents)) ; add to list
  370.     (SetQ new (Cdr (Assoc 2 (TblNext tbl)))) ; get next entry name
  371.   )
  372.   (SetQ tblents (Qsort tblents)) ; sort the name list
  373. )
  374.  
  375. ;;;  Obtain next (Or first) entry from sorted entry list.
  376.  
  377. (DeFun NEXT (first / temp)
  378.   (SetQ temp (Car tblents))        ; get next name from list
  379.   (If temp
  380.     (Progn                         ; if not end of list...
  381.       (SetQ tblents (Cdr tblents)) ; chop from list
  382.       (TblSearch tblname temp)     ; get table entry for this name
  383.     )
  384.   )
  385. )
  386.  
  387. ;;;  Obtain next (Or first) vports entry from sorted entry list.
  388.  
  389. (DeFun NEXTVP (first prev / temp)
  390.   (If first
  391.     (SetQ temp (Car tblents))     ; get first name from list
  392.     (Progn
  393.       (SetQ prev (Car tblents))   ; store previous name
  394.       (SetQ temp (Cadr tblents))  ; get next name from list
  395.     )
  396.   )
  397.   (If temp
  398.     (Progn
  399.       (If (Null first)
  400.         (SetQ tblents (Cdr tblents)); chop from list
  401.       )
  402.       (If (= prev temp)
  403.         (Progn
  404.           (SetQ prev temp)
  405.           (TblNext tblname first) ; get next table entry
  406.         )
  407.         (Progn
  408.           (SetQ prev temp)
  409.           (TblSearch tblname temp T) ; get table entry for this name
  410.         )
  411.       )
  412.     )
  413.   )
  414. )
  415.  
  416. (Princ "\neTables.Lsp loaded, Enter \"ETABLES\" or \"TABLES\" to run...")
  417. (Princ)
  418.  
  419.